MacHack 1998/MacHack 1998.toast/Papers/From CodeWarrior to Delphi/PortableMemory.p

Text File | 1998-06-17 | 6.5 KB | 347 lines | [TEXT/CWIE]

UNIT PortableMemory;

INTERFACE

{$IFC UNDEFINED INTEL}
{$SETC INTEL=FALSE}
{$ENDC}

{$IFC INTEL}
USES
    Settings;
{$ELSEC}
USES
    Settings, Memory;
{$ENDC}

TYPE
{$IFC WINTARGET}
    Chunk = LPVOID;
{$ENDC}
{$IFC MACTARGET}
    Chunk = Handle;
{$ENDC}

PROCEDURE MoveBytes (source: Ptr; dest: Ptr; nb: longint);

FUNCTION MakeChunk (siz: longint; VAR c: Chunk): longint;
FUNCTION SetChunkSize (VAR c: Chunk; siz: longint): longint;
FUNCTION GetChunkSize (VAR c: Chunk): longint;
FUNCTION SetChunkEntry (VAR c: Chunk; recSiz: longint; pEntry: ptr; entrynum: longint): longint;
FUNCTION GetChunkEntry (VAR c: Chunk; recSiz: longint; pEntry: ptr; entrynum: longint): longint;
FUNCTION ZapChunk (VAR c: Chunk): longint;
PROCEDURE LockChunk (c: Chunk);
PROCEDURE UnlockChunk (c: Chunk);
FUNCTION DuplicateChunk (c: Chunk; VAR newchunk: Chunk): longint;
FUNCTION AppendChunk (cFrom: Chunk; VAR cTo: Chunk; sizFrom, sizTo: longint): longint;


IMPLEMENTATION


CONST
    mNoErr = 0;
    mChunkIsNil = 15900;
    mHeapAllocErr = 15901;
    mHeapReAllocErr = 15902;
    mIndexTooLow = 15912;
    mIndexTooHigh = 15913;

{===================================================================}

PROCEDURE MoveBytes (source: Ptr; dest: Ptr; nb: longint);
{$IFC WINTARGET}
    TYPE
        buffer = PACKED ARRAY[1..30000] OF char;
        BufPtr = ^buffer;
    VAR
        ix: integer;
    BEGIN
        FOR ix := 1 TO nb DO
            BufPtr(dest)^[ix] := BufPtr(source)^[ix];

        { should use CopyMemory(dest, source, nb); but it has problems}
    END;
{$ENDC}
{$IFC MACTARGET}
BEGIN
    BlockMove(source, dest, nb);
END;
{$ENDC}

{--------------------------------------------------------------------------------}

{$IFC WINTARGET}

FUNCTION MakeChunk (siz: longint; VAR c: Chunk): longint;
VAR
    err: longint;
BEGIN
    c := HeapAlloc(GetProcessHeap, HEAP_ZERO_MEMORY, siz);

    IF c = NIL THEN
        BEGIN
            err := GetLastError;
            IF err = 0 THEN
                err := mHeapAllocErr;
        END
    ELSE
        BEGIN
            err := mNoErr;
{I'm not sure that ZeroMemory works yet --}
{$IFC FALSE}
    {$pragmac noreturn on}
            ZeroMemory(c, siz);
    {$pragmac noreturn reset}
{$ENDC}
        END;
    MakeChunk := err;
END;


{$IFC FALSE}
{Example from Nadine:}
{            program test;}
{            uses}
{                 windows;}
{            var}
{                 dest, src :^unsignedbyte;}
{            begin}
{            {$pragmac noreturn on}
ZeroMemory(dest, sizeof(dest));
FillMemory(dest, sizeof(dest), 1);
CopyMemory(dest, src, sizeof(dest));
MoveMemory(dest, src, sizeof(dest));
            {$pragmac noreturn reset}
{$ENDC}


FUNCTION SetChunkSize (VAR c: Chunk; siz: longint): longint;
VAR
    newc: Chunk;
    err: longint;
BEGIN
    IF c = NIL THEN
        err := mChunkIsNil
    ELSE
        BEGIN
            newc := HeapReAlloc(GetProcessHeap, 0, c, siz);
            IF newc = NIL THEN
                BEGIN
                    err := GetLastError;
                    IF err = 0 THEN
                        err := mHeapReAllocErr;
                END
            ELSE
                BEGIN
                    err := mNoErr;
                    c := newc;
                END;
        END;
    SetChunkSize := err;
END;


FUNCTION GetChunkSize (VAR c: Chunk): longint;
BEGIN
    IF c = NIL THEN
        GetChunkSize := 0
    ELSE
        GetChunkSize := HeapSize(GetProcessHeap, 0, c);
END;


FUNCTION ZapChunk (VAR c: Chunk): longint;
VAR
    b: BOOL;
BEGIN
    b := HeapFree(GetProcessHeap, 0, c);
    IF b <> 0 THEN
        ZapChunk := mNoErr
    ELSE
        ZapChunk := GetLastError;
END;


PROCEDURE LockChunk (c: Chunk);
BEGIN
END;

PROCEDURE UnlockChunk (c: Chunk);
BEGIN
END;

{$ENDC}

{--------------------------------------------------------------------------------}

{$IFC MACTARGET}

FUNCTION MakeChunk (siz: longint; VAR c: Chunk): longint;
BEGIN
    c := NewHandleClear(siz);
    MakeChunk := MemError;
END;

FUNCTION SetChunkSize (VAR c: Chunk; siz: longint): longint;
BEGIN
    SetHandleSize(c, siz);
    SetChunkSize := mNoErr;
END;


FUNCTION GetChunkSize (VAR c: Chunk): longint;
BEGIN
    GetChunkSize := GetHandleSize(c);
END;


FUNCTION ZapChunk (VAR c: Chunk): longint;
BEGIN
    DisposeHandle(c);
    c := NIL;
    ZapChunk := mNoErr;
END;


PROCEDURE LockChunk (c: Chunk);
BEGIN
    HLock(c);
END;


PROCEDURE UnlockChunk (c: Chunk);
BEGIN
    HUnlock(c);
END;


FUNCTION DuplicateChunk (c: Chunk; VAR newchunk: Chunk): longint;
VAR
    nc: Chunk;
BEGIN
    nc := c;
    DuplicateChunk := HandToHand(nc);
    newchunk := nc;
END;


FUNCTION AppendChunk (cFrom: Chunk; VAR cTo: Chunk; sizFrom, sizTo: longint): longint;
BEGIN
    AppendChunk := HandAndHand(cFrom, cTo); {append c1 to end of c2}
END;

{$ENDC}

{--------------------------------------------------------------------------------}

{The following routines work for both Mac and Win}

FUNCTION CheckChunkSizeForEntryRequested (c: Chunk; recSize, recNum: longint): longint;
VAR
    err, siz, sizNeeded: longint;
BEGIN
    err := 0;
    IF recNum <= 0 THEN
        err := mIndexTooLow
    ELSE
        BEGIN
            siz := GetChunkSize(c);
            sizNeeded := recSize * recNum;
            IF sizNeeded > siz THEN
                err := mIndexTooHigh;
        END;
    CheckChunkSizeForEntryRequested := err;
END;


FUNCTION SetChunkEntry (VAR c: Chunk; recSiz: longint; pEntry: ptr; entrynum: longint): longint;
VAR
    err: longint;
    dest: ptr;
BEGIN
    err := CheckChunkSizeForEntryRequested(c, recSiz, entrynum);
    IF err = 0 THEN
        BEGIN
{$IFC MACTARGET}
            dest := PTR(ORD(c^) + (entrynum - 1) * recSiz);
{$ENDC}
{$IFC WINTARGET}
            dest := PTR(ORD(c) + (entrynum - 1) * recSiz);
{$ENDC}
            MoveBytes(pEntry, dest, recSiz);
        END;

    SetChunkEntry := err;
END;


FUNCTION GetChunkEntry (VAR c: Chunk; recSiz: longint; pEntry: ptr; entrynum: longint): longint;
VAR
    err: longint;
    src: ptr;
BEGIN
    err := CheckChunkSizeForEntryRequested(c, recSiz, entrynum);
    IF err = 0 THEN
        BEGIN
{$IFC MACTARGET}
            src := PTR(ORD(c^) + (entrynum - 1) * recSiz);
{$ENDC}
{$IFC WINTARGET}
            src := PTR(ORD(c) + (entrynum - 1) * recSiz);
{$ENDC}
            MoveBytes(src, pEntry, recSiz);
        END;

    GetChunkEntry := err;
END;


FUNCTION DuplicateChunk (c: Chunk; VAR newchunk: Chunk): longint;
VAR
    err, siz: longint;
BEGIN
    siz := GetChunkSize(c);
    newchunk := HeapAlloc(GetProcessHeap, 0, siz);
    IF newchunk = NIL THEN
        BEGIN
            err := GetLastError;
            IF err = 0 THEN
                err := mHeapAllocErr;
        END
    ELSE
        BEGIN
{$IFC MACTARGET}
            MoveBytes(PTR(c^), PTR(newchunk^), siz);
{$ENDC}
{$IFC WINTARGET}
            MoveBytes(PTR(c), PTR(newchunk), siz);
{$ENDC}
        END;
    DuplicateChunk := err;
END;


FUNCTION AppendChunk (cFrom: Chunk; VAR cTo: Chunk; sizFrom, sizTo: longint): longint;
VAR
    siz, err: longint;
BEGIN
    siz := sizFrom + sizTo;
    err := SetChunkSize(cTo, siz);    {enlarge c2}
    IF err = 0 THEN
            {append cFrom to end of cTo}
        BEGIN
{$IFC MACTARGET}
            MoveBytes(PTR(cFrom^), PTR(ORD(cTo^) + sizTo), siz);
{$ENDC}
{$IFC WINTARGET}
            MoveBytes(PTR(cFrom), PTR(ORD(cTo) + sizTo), siz);
{$ENDC}
        END;

    AppendChunk := err;
END;

{--------------------------------------------------------------------------------}

END.